home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / strings.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-06-16  |  11.6 KB  |  539 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42.  
  43. #include <stdio.h>
  44. #include "_scm.h"
  45.  
  46.  
  47.  
  48. /* {Strings}
  49.  */
  50.  
  51. static char s_string[];
  52.  
  53. #ifdef __STDC__
  54. SCM 
  55. scm_makstr (long len, int slots)
  56. #else
  57. SCM 
  58. scm_makstr (len, slots)
  59.      long len;
  60.      int slots;
  61. #endif
  62. {
  63.   SCM s;
  64.   SCM * mem;
  65.   NEWCELL (s);
  66.   --slots;
  67.   REDEFER_INTS;
  68.   mem = (SCM *)scm_must_malloc (sizeof (SCM) * (slots + 1) + len + 1,
  69.                 s_string);
  70.   if (slots >= 0)
  71.     {
  72.       int x;
  73.       mem[slots] = (SCM)mem;
  74.       for (x = 0; x < slots; ++x)
  75.     mem[x] = BOOL_F;
  76.     }
  77.   SETCHARS (s, (char *) (mem + slots + 1));
  78.   SETLENGTH (s, len, tc7_string);
  79.   REALLOW_INTS;
  80.   CHARS (s)[len] = 0;
  81.   return s;
  82. }
  83.  
  84. /* converts C scm_array of strings to SCM scm_list of strings. */
  85. /* If argc < 0, a null terminated scm_array is assumed. */
  86. #ifdef __STDC__
  87. SCM 
  88. scm_makfromstrs (int argc, char **argv)
  89. #else
  90. SCM 
  91. scm_makfromstrs (argc, argv)
  92.      int argc;
  93.      char **argv;
  94. #endif
  95. {
  96.   int i = argc;
  97.   SCM lst = EOL;
  98.   if (0 > i)
  99.     for (i = 0; argv[i]; i++);
  100.   while (i--)
  101.     lst = scm_cons (scm_makfromstr (argv[i], (sizet) strlen (argv[i]), 0), lst);
  102.   return lst;
  103. }
  104.  
  105. #ifdef __STDC__
  106. SCM
  107. scm_take0str (char * it)
  108. #else
  109. SCM
  110. scm_take0str (it)
  111.      char * it;
  112. #endif
  113. {
  114.   SCM answer;
  115.   NEWCELL (answer);
  116.   DEFER_INTS;
  117.   SETLENGTH (answer, strlen (it), tc7_string);
  118.   CHARS (answer) = it;
  119.   ALLOW_INTS;
  120.   return answer;
  121. }
  122.  
  123. #ifdef __STDC__
  124. SCM 
  125. scm_makfromstr (char *src, sizet len, int slots)
  126. #else
  127. SCM 
  128. scm_makfromstr (src, len, slots)
  129.      char *src;
  130.      sizet len;
  131.      int slots;
  132. #endif
  133. {
  134.   SCM s;
  135.   register char *dst;
  136.   s = scm_makstr ((long) len, slots);
  137.   dst = CHARS (s);
  138.   while (len--)
  139.     *dst++ = *src++;
  140.   return s;
  141. }
  142.  
  143.  
  144. #ifdef __STDC__
  145. SCM 
  146. makfrom0str (char *src)
  147. #else
  148. SCM 
  149. makfrom0str (src)
  150.      char *src;
  151. #endif
  152. {
  153.   if (!src) return BOOL_F;
  154.   return scm_makfromstr (src, (sizet) strlen (src), 0);
  155. }
  156.  
  157. #ifdef __STDC__
  158. SCM 
  159. makfrom0str_opt (char *src)
  160. #else
  161. SCM 
  162. makfrom0str_opt (src)
  163.      char *src;
  164. #endif
  165. {
  166.   return makfrom0str (src);
  167. }
  168.  
  169.  
  170. PROC (s_string_p, "string?", 1, 0, 0, scm_string_p);
  171. #ifdef __STDC__
  172. SCM
  173. scm_string_p (SCM x)
  174. #else
  175. SCM
  176. scm_string_p (x)
  177.      SCM x;
  178. #endif
  179. {
  180.   if (IMP (x))
  181.     return BOOL_F;
  182.   return STRINGP (x) ? BOOL_T : BOOL_F;
  183. }
  184.  
  185. PROC (s_list_to_string, "list->string", 1, 0, 0, scm_string);
  186. PROC (s_string, "string", 0, 0, 1, scm_string);
  187. #ifdef __STDC__
  188. SCM
  189. scm_string (SCM chrs)
  190. #else
  191. SCM
  192. scm_string (chrs)
  193.      SCM chrs;
  194. #endif
  195. {
  196.   SCM res;
  197.   register char *data;
  198.   long i = scm_ilength (chrs);
  199.   ASSERT (i >= 0, chrs, ARG1, s_string);
  200.   res = scm_makstr (i, 0);
  201.   data = CHARS (res);
  202.   for (;NNULLP (chrs);chrs = CDR (chrs)) {
  203.     ASSERT (ICHRP (CAR (chrs)), chrs, ARG1, s_string);
  204.     *data++ = ICHR (CAR (chrs));
  205.   }
  206.   return res;
  207. }
  208.  
  209. PROC (s_make_string, "make-string", 1, 1, 0, scm_make_string);
  210. #ifdef __STDC__
  211. SCM
  212. scm_make_string (SCM k, SCM chr)
  213. #else
  214. SCM
  215. scm_make_string (k, chr)
  216.      SCM k;
  217.      SCM chr;
  218. #endif
  219. {
  220.   SCM res;
  221.   register char *dst;
  222.   register long i;
  223.   ASSERT (INUMP (k) && (k >= 0), k, ARG1, s_make_string);
  224.   i = INUM (k);
  225.   res = scm_makstr (i, 0);
  226.   dst = CHARS (res);
  227.   if ICHRP (chr) for (i--;i >= 0;i--) dst[i] = ICHR (chr);
  228.   return res;
  229. }
  230.  
  231. PROC (s_string_length, "string-length", 1, 0, 0, scm_string_length);
  232. #ifdef __STDC__
  233. SCM
  234. scm_string_length (SCM str)
  235. #else
  236. SCM
  237. scm_string_length (str)
  238.      SCM str;
  239. #endif
  240. {
  241.   ASSERT (NIMP (str) && ROSTRINGP (str), str, ARG1, s_string_length);
  242.   return MAKINUM (LENGTH (str));
  243. }
  244.  
  245. PROC (s_string_ref, "string-ref", 2, 0, 0, scm_string_ref);
  246. #ifdef __STDC__
  247. SCM
  248. scm_string_ref (SCM str, SCM k)
  249. #else
  250. SCM
  251. scm_string_ref (str, k)
  252.      SCM str;
  253.      SCM k;
  254. #endif
  255. {
  256.   ASSERT (NIMP (str) && ROSTRINGP (str), str, ARG1, s_string_ref);
  257.   ASSERT (INUMP (k), k, ARG2, s_string_ref);
  258.   ASSERT (INUM (k) < LENGTH (str) && INUM (k) >= 0, k, OUTOFRANGE, s_string_ref);
  259.   return MAKICHR (CHARS (str)[INUM (k)]);
  260. }
  261.  
  262. PROC (s_string_set_x, "string-set!", 3, 0, 0, scm_string_set_x);
  263. #ifdef __STDC__
  264. SCM
  265. scm_string_set_x (SCM str, SCM k, SCM chr)
  266. #else
  267. SCM
  268. scm_string_set_x (str, k, chr)
  269.      SCM str;
  270.      SCM k;
  271.      SCM chr;
  272. #endif
  273. {
  274.   ASSERT (NIMP (str) && STRINGP (str), str, ARG1, s_string_set_x);
  275.   ASSERT (INUMP (k), k, ARG2, s_string_set_x);
  276.   ASSERT (ICHRP (chr), chr, ARG3, s_string_set_x);
  277.   ASSERT (INUM (k) < LENGTH (str) && INUM (k) >= 0, k, OUTOFRANGE, s_string_set_x);
  278.   CHARS (str)[INUM (k)] = ICHR (chr);
  279.   return UNSPECIFIED;
  280. }
  281.  
  282.  
  283. PROC1 (s_string_equal_p, "string=?", tc7_rpsubr, scm_string_equal_p);
  284. #ifdef __STDC__
  285. SCM
  286. scm_string_equal_p (SCM s1, SCM s2)
  287. #else
  288. SCM
  289. scm_string_equal_p (s1, s2)
  290.      SCM s1;
  291.      SCM s2;
  292. #endif
  293. {
  294.   register sizet i;
  295.   register char *c1, *c2;
  296.   ASSERT (NIMP (s1) && ROSTRINGP (s1), s1, ARG1, s_string_equal_p);
  297.   ASSERT (NIMP (s2) && ROSTRINGP (s2), s2, ARG2, s_string_equal_p);
  298.   i = LENGTH (s2);
  299.   if (LENGTH (s1) != i) return BOOL_F;
  300.   c1 = CHARS (s1);
  301.   c2 = CHARS (s2);
  302.   while (0 != i--) if (*c1++ != *c2++) return BOOL_F;
  303.   return BOOL_T;
  304. }
  305.  
  306. PROC1 (s_string_ci_equal_p, "string-ci=?", tc7_rpsubr, scm_string_ci_equal_p);
  307. #ifdef __STDC__
  308. SCM
  309. scm_string_ci_equal_p (SCM s1, SCM s2)
  310. #else
  311. SCM
  312. scm_string_ci_equal_p (s1, s2)
  313.      SCM s1;
  314.      SCM s2;
  315. #endif
  316. {
  317.   register sizet i;
  318.   register unsigned char *c1, *c2;
  319.   ASSERT (NIMP (s1) && ROSTRINGP (s1), s1, ARG1, s_string_ci_equal_p);
  320.   ASSERT (NIMP (s2) && ROSTRINGP (s2), s2, ARG2, s_string_ci_equal_p);
  321.   i = LENGTH (s2);
  322.   if (LENGTH (s1) != i) return BOOL_F;
  323.   c1 = UCHARS (s1);
  324.   c2 = UCHARS (s2);
  325.   while (0 != i--) if (scm_upcase[*c1++] != scm_upcase[*c2++]) return BOOL_F;
  326.   return BOOL_T;
  327. }
  328.  
  329. PROC1 (s_string_less_p, "string<?", tc7_rpsubr, scm_string_less_p);
  330. #ifdef __STDC__
  331. SCM
  332. scm_string_less_p (SCM s1, SCM s2)
  333. #else
  334. SCM
  335. scm_string_less_p (s1, s2)
  336.      SCM s1;
  337.      SCM s2;
  338. #endif
  339. {
  340.   register sizet i, len;
  341.   register unsigned char *c1, *c2;
  342.   register int c;
  343.   ASSERT (NIMP (s1) && ROSTRINGP (s1), s1, ARG1, s_string_less_p);
  344.   ASSERT (NIMP (s2) && ROSTRINGP (s2), s2, ARG2, s_string_less_p);
  345.   len = LENGTH (s1);
  346.   i = LENGTH (s2);
  347.   if (len>i) i = len;
  348.   c1 = UCHARS (s1);
  349.   c2 = UCHARS (s2);
  350.   for (i = 0;i<len;i++) {
  351.     c = (*c1++ - *c2++);
  352.     if (c>0) return BOOL_F;
  353.     if (c<0) return BOOL_T;
  354.   }
  355.   return (LENGTH (s2) != len) ? BOOL_T : BOOL_F;
  356. }
  357.  
  358. PROC1 (s_string_leq_p, "string<=?", tc7_rpsubr, scm_string_leq_p);
  359. #ifdef __STDC__
  360. SCM
  361. scm_string_leq_p (SCM s1, SCM s2)
  362. #else
  363. SCM
  364. scm_string_leq_p (s1, s2)
  365.      SCM s1;
  366.      SCM s2;
  367. #endif
  368. {
  369.   return BOOL_NOT (scm_string_less_p (s2, s1));
  370. }
  371.  
  372. PROC1 (s_string_gr_p, "string>?", tc7_rpsubr, scm_string_gr_p);
  373. #ifdef __STDC__
  374. SCM
  375. scm_string_gr_p (SCM s1, SCM s2)
  376. #else
  377. SCM
  378. scm_string_gr_p (s1, s2)
  379.      SCM s1;
  380.      SCM s2;
  381. #endif
  382. {
  383.   return scm_string_less_p (s2, s1);
  384. }
  385.  
  386. PROC1 (s_string_geq_p, "string>=?", tc7_rpsubr, scm_string_geq_p);
  387. #ifdef __STDC__
  388. SCM
  389. scm_string_geq_p (SCM s1, SCM s2)
  390. #else
  391. SCM
  392. scm_string_geq_p (s1, s2)
  393.      SCM s1;
  394.      SCM s2;
  395. #endif
  396. {
  397.   return BOOL_NOT (scm_string_less_p (s1, s2));
  398. }
  399.  
  400. PROC1 (s_string_ci_less_p, "string-ci<?", tc7_rpsubr, scm_string_ci_less_p);
  401. #ifdef __STDC__
  402. SCM
  403. scm_string_ci_less_p (SCM s1, SCM s2)
  404. #else
  405. SCM
  406. scm_string_ci_less_p (s1, s2)
  407.      SCM s1;
  408.      SCM s2;
  409. #endif
  410. {
  411.   register sizet i, len;
  412.   register unsigned char *c1, *c2;
  413.   register int c;
  414.   ASSERT (NIMP (s1) && ROSTRINGP (s1), s1, ARG1, s_string_ci_less_p);
  415.   ASSERT (NIMP (s2) && ROSTRINGP (s2), s2, ARG2, s_string_ci_less_p);
  416.   len = LENGTH (s1);
  417.   i = LENGTH (s2);
  418.   if (len>i) i=len;
  419.   c1 = UCHARS (s1);
  420.   c2 = UCHARS (s2);
  421.   for (i = 0;i<len;i++) {
  422.     c = (scm_upcase[*c1++] - scm_upcase[*c2++]);
  423.     if (c>0) return BOOL_F;
  424.     if (c<0) return BOOL_T;
  425.   }
  426.   return (LENGTH (s2) != len) ? BOOL_T : BOOL_F;
  427. }
  428.  
  429. PROC1 (s_string_ci_leq_p, "string-ci<=?", tc7_rpsubr, scm_string_ci_leq_p);
  430. #ifdef __STDC__
  431. SCM
  432. scm_string_ci_leq_p (SCM s1, SCM s2)
  433. #else
  434. SCM
  435. scm_string_ci_leq_p (s1, s2)
  436.      SCM s1;
  437.      SCM s2;
  438. #endif
  439. {
  440.   return BOOL_NOT (scm_string_ci_less_p (s2, s1));
  441. }
  442.  
  443. PROC1 (s_string_ci_gr_p, "string-ci>?", tc7_rpsubr, scm_string_ci_gr_p);
  444. #ifdef __STDC__
  445. SCM
  446. scm_string_ci_gr_p (SCM s1, SCM s2)
  447. #else
  448. SCM
  449. scm_string_ci_gr_p (s1, s2)
  450.      SCM s1;
  451.      SCM s2;
  452. #endif
  453. {
  454.   return scm_string_ci_less_p (s2, s1);
  455. }
  456.  
  457. PROC1 (s_string_ci_geq_p, "string-ci>=?", tc7_rpsubr, scm_string_ci_geq_p);
  458. #ifdef __STDC__
  459. SCM
  460. scm_string_ci_geq_p (SCM s1, SCM s2)
  461. #else
  462. SCM
  463. scm_string_ci_geq_p (s1, s2)
  464.      SCM s1;
  465.      SCM s2;
  466. #endif
  467. {
  468.   return BOOL_NOT (scm_string_ci_less_p (s1, s2));
  469. }
  470.  
  471. PROC (s_substring, "substring", 3, 0, 0, scm_substring);
  472. #ifdef __STDC__
  473. SCM
  474. scm_substring (SCM str, SCM start, SCM end)
  475. #else
  476. SCM
  477. scm_substring (str, start, end)
  478.      SCM str;
  479.      SCM start;
  480.      SCM end;
  481. #endif
  482. {
  483.   long l;
  484.   ASSERT (NIMP (str) && ROSTRINGP (str),
  485.      str, ARG1, s_substring);
  486.   ASSERT (INUMP (start), start, ARG2, s_substring);
  487.   ASSERT (INUMP (end), end, ARG3, s_substring);
  488.   ASSERT (INUM (start) <= LENGTH (str), start, OUTOFRANGE, s_substring);
  489.   ASSERT (INUM (end) <= LENGTH (str), end, OUTOFRANGE, s_substring);
  490.   l = INUM (end)-INUM (start);
  491.   ASSERT (l >= 0, MAKINUM (l), OUTOFRANGE, s_substring);
  492.   return scm_makfromstr (&CHARS (str)[INUM (start)], (sizet)l, 0);
  493. }
  494.  
  495. PROC (s_string_append, "string-append", 0, 0, 1, scm_string_append);
  496. #ifdef __STDC__
  497. SCM
  498. scm_string_append (SCM args)
  499. #else
  500. SCM
  501. scm_string_append (args)
  502.      SCM args;
  503. #endif
  504. {
  505.   SCM res;
  506.   register long i = 0;
  507.   register SCM l, s;
  508.   register char *data;
  509.   for (l = args;NIMP (l);) {
  510.     ASSERT (CONSP (l), l, ARGn, s_string_append);
  511.     s = CAR (l);
  512.     ASSERT (NIMP (s) && ROSTRINGP (s),
  513.        s, ARGn, s_string_append);
  514.     i += LENGTH (s);
  515.     l = CDR (l);
  516.   }
  517.   ASSERT (NULLP (l), args, ARGn, s_string_append);
  518.   res = scm_makstr (i, 0);
  519.   data = CHARS (res);
  520.   for (l = args;NIMP (l);l = CDR (l)) {
  521.     s = CAR (l);
  522.     for (i = 0;i<LENGTH (s);i++) *data++ = CHARS (s)[i];
  523.   }
  524.   return res;
  525. }
  526.  
  527.  
  528. #ifdef __STDC__
  529. void
  530. scm_init_strings (void)
  531. #else
  532. void
  533. scm_init_strings ()
  534. #endif
  535. {
  536. #include "strings.x"
  537. }
  538.  
  539.